home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / quadlap.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  17.5 KB  |  623 lines
  1. ;;                -[Thu Mar  1 10:54:27 1990 by jkf]-
  2. ;; pcl to quad translation
  3. ;; $Header: quadlap.cl,v 1.1 90/02/21 08:54:42 jkf Exp Locker: jkf $
  4. ;;
  5. ;; copyright (c) 1990 Franz Inc.
  6. ;;
  7. (in-package :compiler)
  8.  
  9.  
  10.  
  11.  
  12. (defvar *arg-to-treg* nil)
  13. (defvar *cvar-to-index* nil)
  14. (defvar *reg-array* nil)
  15. (defvar *closure-treg* nil)
  16. (defvar *nargs-treg* nil)
  17.  
  18. (defvar *debug-sparc* nil)
  19.  
  20. (defmacro pcl-make-lambda (&key required)
  21.   `(list 'lambda nil :unknown-type 0 compiler::.function-level. 
  22.     ,required nil nil nil nil nil nil nil nil nil 
  23.     nil 'compiler::none nil nil nil 
  24.     nil nil nil nil nil nil 0 nil))
  25.  
  26. (defmacro pcl-make-varrec (&key name loc contour-level)
  27.   `(list ,name nil 0 nil ,loc nil t compiler::.function-level. nil nil :unknown-type nil nil ,contour-level))
  28.  
  29. (defmacro pcl-make-lap (&key lap constants cframe-size locals)
  30.   `(list nil ,constants ,lap nil nil ,cframe-size ,locals nil nil nil))
  31.  
  32.  
  33. (defstruct (preg)
  34.   ;; pseudo reg descritpor
  35.   treg        ; associated treg
  36.   index     ; :index if this is an index type reg
  37.           ; :vector if this is a vector type reg
  38.   )
  39.  
  40.  
  41. (defun pcl::excl-lap-closure-generator (closure-vars-names
  42.                    arg-names
  43.                    index-regs
  44.                    vector-regs
  45.                    fixnum-vector-regs
  46.                    t-regs
  47.                    lap-code)
  48.   (let ((function (pcl::excl-lap-closure-gen closure-vars-names
  49.                    arg-names
  50.                    index-regs
  51.                    (append vector-regs fixnum-vector-regs)
  52.                    t-regs
  53.                    lap-code)))
  54.     #'(lambda (&rest closure-vals)
  55.     (insert-closure-vals function closure-vals))))
  56.  
  57.  
  58. (defun pcl::excl-lap-closure-gen
  59.     (closure-vars-names arg-names index-regs vector-regs t-regs lap-code)
  60.   (let ((*quads* nil)
  61.     (*treg-num* 0)
  62.     (*all-tregs* nil)
  63.     (*bb-count* 0)
  64.     *treg-bv-size*
  65.     *treg-vector*
  66.     (*next-catch-frame* 0)
  67.     (*max-catch-frame* -1)
  68.     *catch-labels*
  69.     *top-label*
  70.     *mv-treg*
  71.     *mv-treg-target*
  72.     *zero-treg*
  73.     *nil-treg*
  74.     *bbs* *bb* lap
  75.     ;; bbs
  76.     *cross-block-regs*
  77.     *const-tregs* *move-tregs*
  78.     *actuals*
  79.     *ignore-argcount*
  80.     *binds-specs*
  81.     *bvl-current-bv* ; for bitvector cacher
  82.     *bvl-used-bvs*
  83.     *bvl-index*
  84.     (*inhibit-call-count* t)
  85.     
  86.     ; this fcn
  87.     *arg-to-treg*
  88.     *cvar-to-index* 
  89.     *reg-array*
  90.     minargs
  91.     maxargs
  92.     *closure-treg*
  93.  
  94.     node
  95.     otherargregs
  96.     
  97.     *nargs-treg*
  98.     )
  99.  
  100.     (if* *debug-sparc* 
  101.        then (format t ">>** << Generating sparc lap code~%"))
  102.     
  103.     (setq *nil-treg* 
  104.       #+allegro-v4.0 (new-reg :global t)
  105.       #-allegro-v4.0 (new-reg)
  106.       *mv-treg* (new-reg)
  107.       *mv-treg-target* (list *mv-treg*)
  108.       *zero-treg* (comp::new-reg))
  109.     
  110.     ; examine given args
  111.     
  112.     (setq minargs 0  maxargs 0)
  113.     (let (requireds)
  114.       (dolist (arg arg-names)
  115.     (if* (eq '&rest arg)
  116.        then (setq maxargs nil)
  117.        else (if* (null arg)
  118.            then ; we want a name even though we won't use it
  119.             (setq arg (gensym)))
  120.         (incf minargs)
  121.         (incf maxargs)
  122.         (push (cons arg (new-reg)) *arg-to-treg*)
  123.         (push (pcl-make-varrec :name arg 
  124.                    :loc (cdr (car *arg-to-treg*))
  125.                    :contour-level 0)
  126.               requireds)
  127.         ))
  128.       (setq node (pcl-make-lambda :required  (nreverse requireds))))
  129.     (setq *arg-to-treg* (nreverse *arg-to-treg*))
  130.     
  131.     ; build closure vector list
  132.     (let ((index -1))
  133.       (dolist (cvar closure-vars-names)
  134.     (push (cons cvar (incf index)) *cvar-to-index*)))
  135.     
  136.     (let ((maxreg (max (apply #'max (cons -1 index-regs))
  137.                (apply #'max (cons -1 vector-regs))
  138.                (apply #'max (cons -1 t-regs)))))
  139.       (setq *reg-array* (make-array (1+ maxreg))))
  140.     
  141.     (dolist (index index-regs)
  142.       (setf (svref *reg-array* index)
  143.     (make-preg :treg (new-reg)
  144.            :index :index)))
  145.     
  146.     (dolist (vector vector-regs)
  147.       (setf (svref *reg-array* vector) 
  148.     (make-preg :treg (new-reg)
  149.            :index :vector)))
  150.     
  151.     (dolist (tr t-regs)
  152.       (setf (svref *reg-array* tr) (make-preg :treg (new-reg))))
  153.     
  154.  
  155.     (if* closure-vars-names
  156.        then (setq *closure-treg* (new-reg)))
  157.     (setq *nargs-treg* (new-reg))
  158.         
  159.     ;; (md-allocate-global-tregs)
  160.     
  161.     ; function entry
  162.     (qe nop :arg :first-block)
  163.     (qe entry)
  164.     (qe argcount :arg (list minargs maxargs))
  165.     (qe lambda :d (mapcar #'cdr *arg-to-treg*))
  166.     (qe register :arg :nargs :d (list *nargs-treg*))
  167.  
  168.     (if* *closure-treg*
  169.        then ; put the first closure vector in *closure-treg*
  170.         (qe extract-closure-vec :d (list *closure-treg*))
  171.         (let ((offsetreg (new-reg)))
  172.           (qe const :arg (mdparam 'md-cons-car-adj) :d (list offsetreg))
  173.           (qe ref :u (list *closure-treg* offsetreg) 
  174.           :d (list *closure-treg*)
  175.           :arg :long))
  176.         )
  177.  
  178.     (excl-gen-quads lap-code)
  179.  
  180.     (if* *debug-sparc*
  181.        then (do-quad-list (quad next *quads*)
  182.           (format t "~a~%" quad))
  183.  
  184.         (format t "basic blocks~%"))
  185.     
  186.     (setq *bbs* (qc-compute-basic-blocks *quads*))
  187.     
  188.     (excl::target-class-case
  189.      ((:r :m) (setq *actuals* (qc-compute-actuals *bbs*))))
  190.     
  191.     (qc-live-variable-analysis *bbs*)
  192.     
  193.     (setq *treg-bv-size* (* 16 (truncate (+ *treg-num* 15) 16)))
  194.       
  195.     (qc-build-treg-vector)
  196.     
  197.  
  198.     (let ((*dump-bbs* nil)
  199.       (r::*local-regs*
  200.        ; use the in registers that aren't in use
  201.        (append r::*local-regs*
  202.            (if* maxargs
  203.               then (nthcdr maxargs r::*in-regs* )))))
  204.       (unwind-protect
  205.       (progn
  206.         ; machine specific code generation
  207.         (multiple-value-bind (lap-code literals size-struct locals)
  208.         #+(target-class r m e)
  209.         (progn
  210.           #+allegro-v4.0 
  211.           (md-codegen node *bbs*
  212.                   nil otherargregs)
  213.           #-allegro-v4.0 
  214.           (md-codegen node *bbs*
  215.                   *nil-treg* *mv-treg* *zero-treg*
  216.                   nil otherargregs))
  217.           
  218.         #-(target-class r m e) (md-codegen node *bbs*)
  219.         (setq lap
  220.           (pcl-make-lap :lap lap-code
  221.                 :constants literals
  222.                 :cframe-size size-struct
  223.                 :locals  locals)))
  224.  
  225.          
  226.         lap)
  227.     (giveback-bvs)))
  228.     
  229.     #+ignore 
  230.     (progn (format t "sparc code pre optimization~%")
  231.        (dolist (instr (lap-lap lap))
  232.          (format t "> ~a~%" instr)))
  233.     (md-optimize lap) ; peephole optimize
  234.     (if* *debug-sparc*
  235.        then (format t "sparc code post optimization~%")
  236.         (dolist (instr (lap-lap lap))
  237.           (format t "> ~a~%" instr)))
  238.     (md-assemble lap)
  239.     (setq last-lap lap)
  240.  
  241.     (nl-runtime-make-a-fcnobj lap)))
  242.  
  243. (defun qe-slot-access (operand offset dest)
  244.   ;; access a slot in a structure
  245.   (let ((temp (new-reg)))
  246.     (qe const :arg offset :d (list temp))
  247.     (qe ref :u (list (get-treg-of operand) temp) 
  248.     :d (list (get-treg-of dest))
  249.     :arg :long)))
  250.  
  251.  
  252. (defun get-treg-of (operand &optional res-operand)
  253.   ;; get the appropriate treg for the operand
  254.   (let ((prefer-treg (and res-operand (simple-get-treg-of res-operand))))
  255.     (if* (numberp operand)
  256.        then (let ((treg (new-reg)))
  257.           (qe const :arg operand :d (list treg))
  258.           treg)
  259.      elseif (consp operand)
  260.        then (ecase (car operand)
  261.           (:reg 
  262.            (preg-treg (svref *reg-array* (cadr operand))))
  263.           (:arg 
  264.            (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq))))
  265.          (if* (null x)
  266.             then (error "where is arg ~s" operand)
  267.             else x)))
  268.           (:cvar
  269.            (let ((res-treg (or prefer-treg (new-reg)))
  270.              (temp-treg (new-reg)))
  271.          (qe const :arg (+ (mdparam 'md-svector-data0-adj)
  272.                    (* 4 (cdr (assoc (cadr operand)
  273.                             *cvar-to-index*
  274.                             :test #'eq))))
  275.              :d (list temp-treg))
  276.          (qe ref :u (list *closure-treg* temp-treg)
  277.              :d (list res-treg)
  278.              :arg :long)
  279.          res-treg))
  280.           (:constant
  281.            (let ((treg (or prefer-treg (new-reg))))
  282.          (qe const :arg (if* (fixnump (cadr operand))
  283.                    then (* 8 (cadr operand)) ; md!!
  284.                    else (cadr operand))
  285.              :d (list treg))
  286.          treg))
  287.           (:index-constant
  288.            ; operand invented by jkf to denote an index type constant
  289.            (let ((treg (or prefer-treg (new-reg))))
  290.          (qe const :arg (if* (fixnump (cadr operand))
  291.                    then (* 4 (cadr operand)) ; md!!
  292.                    else (cadr operand))
  293.              :d (list treg))
  294.          treg)))
  295.        else (error "bad operand: ~s" operand))))
  296.  
  297. (defun simple-get-treg-of (operand)
  298.   ;; get the treg if it is so simple that we don't have to 
  299.   ;; emit any instructions to access it.
  300.   ;; return nil if we can't do it.
  301.   (if* (numberp operand)
  302.      then nil
  303.    elseif (consp operand)
  304.      then (case (car operand)
  305.         (:reg 
  306.          (preg-treg (svref *reg-array* (cadr operand))))
  307.         (:arg 
  308.          (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq))))
  309.            (if* (null x)
  310.           then nil
  311.           else x))))
  312.           
  313.      else nil))
  314.  
  315. (defun index-p (operand)
  316.   ;; determine if the result of this operand is an index value
  317.   ;* it would be better if conversion between lisp values and
  318.   ;  index values were made explicit in the lap code
  319.   (and (consp operand)
  320.        (or (and (eq :reg (car operand))
  321.         (eq :index (preg-index (svref *reg-array* (cadr operand)))))
  322.        (member (car operand)
  323.            '(:i+ :i- :ilogand :ilogxor :i1+)
  324.            :test #'eq))
  325.        t))
  326.  
  327. (defun gen-index-treg (operand)
  328.   ;; return the non-index type operand in a index treg
  329.   (if* (and (consp operand)
  330.         (eq ':constant (car operand)))
  331.      then (get-treg-of `(:index-constant ,(cadr operand)))
  332.      else (let ((treg (get-treg-of operand))
  333.         (new-reg (new-reg))
  334.         (shift-reg (new-reg)))
  335.         (qe const :arg 1 :d (list shift-reg))
  336.         (qe lsr :u (list treg shift-reg) :d (list new-reg))
  337.         new-reg)))
  338.  
  339.         
  340.         
  341.   
  342.   
  343. (defun vector-preg-p (operand)
  344.   (and (consp operand)
  345.        (eq :reg (car operand))
  346.        (eq :vector (preg-index (svref *reg-array* (cadr operand))))))
  347.        
  348.         
  349.       
  350. (defun excl-gen-quads (laps)
  351.   ;; generate quads from the lap
  352.   (dolist (lap laps)
  353.     (if* *debug-sparc* then (format t ">> ~a~%" lap))
  354.     (block again
  355.       (let ((opcode (car lap))
  356.         (op1    (cadr lap))
  357.         (op2    (caddr lap)))
  358.     (case opcode
  359.       (:move
  360.        ; can be either simple (both args registers)
  361.        ; or one arg can be complex and the other simple
  362.        (case (car op2)
  363.          (:iref
  364.           ;; assume that this is a lisp store
  365.           ;;(warn "assuming lisp store in ~s" lap)
  366.           (let (op1-treg)
  367.         (if* (not (vector-preg-p (cadr op2)))
  368.            then ; must offset before store
  369.             (error "must use vector register in ~s" lap)
  370.            else (setq op1-treg (get-treg-of (cadr op2))))
  371.                        
  372.                       
  373.         
  374.         (qe set :u (list op1-treg
  375.                  (get-treg-of (caddr op2))
  376.                  (get-treg-of op1))
  377.             :arg :lisp)
  378.         (return-from again)))
  379.          (:cdr
  380.           ;; it certainly is a lisp stoer
  381.           (let (op1-treg const-reg)
  382.         (setq op1-treg (get-treg-of (cadr op2)))
  383.             (setq const-reg (new-reg))
  384.         (qe const :arg (mdparam 'md-cons-cdr-adj) 
  385.             :d (list const-reg))
  386.                        
  387.                       
  388.         
  389.         (qe set :u (list op1-treg
  390.                  const-reg
  391.                  (get-treg-of op1))
  392.             :arg :lisp)
  393.         (return-from again))))
  394.      
  395.        ; the 'to'address is simple, the from address may not be
  396.      
  397.        (let ((index1 (index-p op1))
  398.          (index2 (index-p op2))
  399.          (vector1 (vector-preg-p op1))
  400.          (vector2 (vector-preg-p op2)))
  401.          (ecase (car op1)
  402.            ((:reg :cvar :arg :constant :lisp-symbol)
  403.         (qe move 
  404.             :u (list (get-treg-of op1 op2))
  405.             :d (list (get-treg-of op2))))
  406.            (:std-wrapper
  407.         (qe-slot-access (cadr op1) 
  408.                 (+ (* 1 4)
  409.                    (comp::mdparam 'md-svector-data0-adj))
  410.                 op2))
  411.            (:std-slots
  412.         (qe-slot-access (cadr op1) 
  413.                 (+ (* 2 4)
  414.                    (comp::mdparam 'md-svector-data0-adj))
  415.                 op2))
  416.            (:fsc-wrapper
  417.         (qe-slot-access (cadr op1) 
  418.                 (+ (* (- 15 1) 4)
  419.                    (comp::mdparam 'md-function-const0-adj))
  420.                 op2))
  421.            (:fsc-slots
  422.         (qe-slot-access (cadr op1) 
  423.                 (+ (* (- 15 2) 4)
  424.                    (comp::mdparam 'md-function-const0-adj))
  425.                 op2))
  426.            ((:built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper)
  427.         (qe call :arg 'pcl::built-in-or-structure-wrapper-fun
  428.             :u (list (get-treg-of (cadr op1)))
  429.             :d (list (get-treg-of op2))))
  430.                #+pcl-user-instances
  431.                ((:user-wrapper :user-slots)
  432.                 (warn "Trying to use pcl-user-instances in Sun4 Allegro."))
  433.            (:other-wrapper
  434.         (warn "do other-wrapper"))
  435.            ((:i+ :i- :ilogand :ilogxor)
  436.         (qe arith :arg (cdr (assoc (car op1) 
  437.                        '((:i+ . :+)
  438.                          (:i- . :-)
  439.                          (:ilogand . :logand)
  440.                          (:ilogxor . :logxor))
  441.                        :test #'eq))
  442.             :u (list (get-treg-of (cadr op1))
  443.                  (get-treg-of (caddr op1)))
  444.             :d (list (get-treg-of op2))))
  445.            (:i1+
  446.         (let ((const-reg (new-reg)))
  447.           (qe const :arg 4 ; an index value of 1
  448.               :d (list const-reg))
  449.           (qe arith :arg :+
  450.               :u (list const-reg
  451.                    (get-treg-of (cadr op1)))
  452.               :d (list (get-treg-of op2)))))
  453.               
  454.            ((:iref :cref)
  455.         (let (op1-treg)
  456.           (if* (not (vector-preg-p (cadr op1)))
  457.              then ; must offset before store
  458.               (error "must use vector register in ~s" lap)
  459.              else (setq op1-treg (get-treg-of (cadr op1))))
  460.                        
  461.           (qe ref :u (list op1-treg
  462.                    (get-treg-of (caddr op1) op2))
  463.               :d (list (get-treg-of op2))
  464.               :arg :long)))
  465.            (:cdr
  466.         (let ((const-reg (new-reg)))
  467.           (qe const :arg (mdparam 'md-cons-cdr-adj)
  468.               :d (list const-reg))
  469.           (qe ref :arg :long
  470.               :u (list (get-treg-of (cadr op1))
  471.                    const-reg)
  472.               :d (list (get-treg-of op2))))))
  473.          (if* (not (eq index1 index2))
  474.         then (let ((shiftamt (new-reg)))
  475.                (qe const :arg 1 :d (list shiftamt))
  476.                (if* (and index1 (not index2))
  477.               then ; converting from index to non-index
  478.                    (qe lsl :u (list (get-treg-of op2) shiftamt)
  479.                    :d (list (get-treg-of op2)))
  480.             elseif (and (not index1) index2)
  481.                    ; converting to an index
  482.               then (qe lsr :u (list (get-treg-of op2) shiftamt)
  483.                    :d (list (get-treg-of op2)))))
  484.           elseif (and vector2 (not vector1))
  485.         then ; add vector offset
  486.              (let ((tempreg (new-reg))
  487.                (vreg (get-treg-of op2)))
  488.                (qe const :arg (mdparam 'md-svector-data0-adj)
  489.                :d (list tempreg))
  490.                (qe arith :arg :+ :u (list vreg tempreg)
  491.                :d (list vreg))))))
  492.       (:fix=
  493.        (let (tr1 tr2)
  494.          (if* (index-p op1)
  495.         then (setq tr1 (get-treg-of op1))
  496.              (if* (not (index-p op2))
  497.             then (setq tr2 (gen-index-treg op2))
  498.             else (setq tr2 (get-treg-of op2)))
  499.           elseif (index-p op2)
  500.         then ; assert: op1 isn't an index treg
  501.              (setq tr1 (gen-index-treg op1))
  502.              (setq tr2 (get-treg-of op2))
  503.         else (setq tr1 (get-treg-of op1)
  504.                tr2 (get-treg-of op2)))
  505.        
  506.            
  507.            
  508.          (qe bcc :u (list tr1 tr2)
  509.          :arg (cadddr lap)
  510.          :arg2 :eq )))
  511.       ((:eq :neq :fix=)
  512.        (if* (not (eq (index-p op1) (index-p op2)))
  513.           then (error "non matching operands indexwise in: ~s" lap))
  514.        (qe bcc :u (list (get-treg-of op1)
  515.                 (get-treg-of op2))
  516.            :arg (cadddr lap)
  517.            :arg2 (cdr (assoc opcode '((:eq . :eq)
  518.                       (:neq . :ne))
  519.                  :test #'eq))))
  520.       (:izerop 
  521.        (qe bcc :u (list (get-treg-of op1)
  522.                 *zero-treg*)
  523.            :arg (caddr lap)
  524.            :arg2 :eq))
  525.       (:std-instance-p
  526.        (let ((treg (get-treg-of op1))
  527.          (tempreg (new-reg))
  528.          (temp2reg (new-reg))
  529.          (offsetreg (new-reg))
  530.          (nope (pc-genlab)))
  531.          (qe typecheck :u (list treg)
  532.          :arg nope
  533.          :arg2 '(not structure))
  534.          (qe const :arg 'pcl::std-instance :d (list tempreg))
  535.          (qe const :arg (mdparam 'md-svector-data0-adj) 
  536.          :d (list offsetreg))
  537.          (qe ref :u (list treg offsetreg) 
  538.          :d (list temp2reg)
  539.          :arg :long)
  540.          (qe bcc :arg2 :eq :u (list tempreg temp2reg)
  541.          :arg (caddr lap))
  542.          (qe label :arg nope)))
  543.       
  544.       (:fsc-instance-p
  545.        (let ((treg (get-treg-of op1))
  546.          (nope (pc-genlab))
  547.          (offsetreg (new-reg))
  548.          (tempreg (new-reg))
  549.          (checkreg (new-reg)))
  550.          (qe typecheck :u (list treg)
  551.          :arg nope
  552.          :arg2 '(not compiled-function))
  553.          (qe const :arg (mdparam 'md-function-flags-adj)
  554.          :d (list offsetreg))
  555.          (qe ref :u (list treg offsetreg) :d (list tempreg)
  556.          :arg :ubyte)
  557.          (qe const :arg pcl::funcallable-instance-flag-bit
  558.          :d (list checkreg))
  559.          (qe bcc :u (list checkreg tempreg)
  560.          :arg (caddr lap)
  561.          :arg2 :bit-and)
  562.          (qe label :arg nope)))
  563.       (:built-in-instance-p
  564.        ; always true
  565.        (qe bra :arg (caddr lap)))
  566.       (:jmp
  567.        (qe tail-funcall :u (list *nargs-treg* (get-treg-of op1))))
  568.       (:structure-instance-p
  569.        ; always true
  570.        (qe bra :arg (caddr lap)))
  571.       
  572.       (:return
  573.         (let (op-treg)
  574.           (if* (index-p op1)
  575.          then ; convert to lisp before returning
  576.               (let ((shiftamt (new-reg)))
  577.             (setq op-treg (new-reg))
  578.             (qe const :arg 1 :d (list shiftamt))
  579.             (qe lsl :u (list (get-treg-of op1) shiftamt)
  580.                 :d (list op-treg)))
  581.          else (setq op-treg (get-treg-of op1)))
  582.  
  583.           (qe move :u (list op-treg) :d *mv-treg-target*)
  584.           (qe return :u *mv-treg-target*)))
  585.  
  586.       (:go
  587.        (qe bra :arg (cadr lap)))
  588.        
  589.       (:label 
  590.        (qe label :arg (cadr lap)))
  591.          
  592.        
  593.        
  594.       (t (warn "ignoring ~s" lap)))))))
  595.  
  596.  
  597. (defun insert-closure-vals (function closure-vals)
  598.   ;;  build a fucntion from the lap and insert 
  599.   (let ((newfun (sys::copy-function function)))
  600.     (setf (excl::fn_closure newfun) (list (apply 'vector closure-vals)))
  601.     newfun))
  602.  
  603.   
  604.          
  605. ; test case:
  606. ; (pcl::defclass foo () (a b c))
  607. ; (pcl::defmethod barx ((a foo) b c)  a )
  608. ; (apply 'pcl::excl-lap-closure-generator pcl::*tcase*)
  609. ;
  610. ; to turn it on
  611.  
  612. (if* (not (and (boundp 'user::noquad)
  613.            (symbol-value 'user::noquad)))
  614.    then (setq pcl::*make-lap-closure-generator* 
  615.       'pcl::excl-lap-closure-generator))
  616.  
  617.  
  618.  
  619.  
  620.  
  621.   
  622.  
  623.